home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / AV Parser.Lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  19.8 KB  |  538 lines  |  [TEXT/CCL2]
  1. ;;;  An attribute-value parser.
  2. ;;;  Graphics are provided in a separate file.
  3.  
  4.  
  5. ;;;  Features
  6.  
  7. (defvar *AV-Generation* 0)          ; the generation counter
  8.  
  9. ;;;  if the current generation is generation then the value of the avnode
  10. ;;;  is old-contents, otherwise it is new-contents.
  11.  
  12. (defstruct avnode oldcontents newcontents generation)
  13.  
  14. (defmacro New-Generation () 
  15.   "Increment the global generation counter"
  16.   `(incf *AV-Generation*))
  17.  
  18. (defmacro UpToDate (avnode)
  19.   "T if this node's generation is EQ to the global generation counter"
  20.   `(eq *AV-Generation* (avnode-generation ,avnode)))
  21.  
  22. (defmacro avnode-contents (avnode)
  23.   "The current contents of this node"
  24.   `(if (avnode-p ,avnode)
  25.      (if (UpToDate ,avnode)
  26.        (avnode-newcontents ,avnode)
  27.        (avnode-oldcontents ,avnode))
  28.      ,avnode))
  29.  
  30. ;;;  type predicates on contents
  31.  
  32. (defmacro pointer-p (contents)
  33.   "T if contents are another avnode"
  34.   `(avnode-p ,contents))
  35.  
  36. (defmacro constant-p (contents)
  37.   "T if contents are a constant"
  38.   `(and ,contents (symbolp ,contents)))
  39.  
  40. (defmacro variable-p (contents)
  41.   "T if contents is uninstantiated"
  42.   `(null ,contents))
  43.  
  44. (defmacro complex-p (contents)
  45.   "T if contents are a list of AV pairs"
  46.   `(consp ,contents))
  47.  
  48. ;;;  macros for manipulating the av-pairs of complex nodes
  49.  
  50. (defmacro avpair-att (avp) 
  51.   "The attribute of an AV pair"
  52.   `(car ,avp))
  53.  
  54. (defmacro avpair-val (avp) 
  55.   "The value of an AV pair"
  56.   `(cdr ,avp))
  57.  
  58. (defmacro make-avpair (att val) 
  59.   "AV pair constructor"
  60.   `(cons ,att ,val))
  61.  
  62. (defmacro avpairs-att-val (avps att)
  63.   "The value of the att attribute of avps"
  64.   `(cdr (assoc ,att ,avps)))
  65.  
  66. (defmacro smash-to-pointer (avn1 avn2)
  67.   "Makes avn1 point to avn2"
  68.   `(progn (setf (avnode-generation ,avn1) *AV-Generation*)
  69.           (setf (avnode-newcontents ,avn1) ,avn2)))
  70.  
  71. (defmacro copy-contents (avn)
  72.   "Replaces avn's newcontents with a copy of its oldcontents"
  73.   `(progn (setf (avnode-generation ,avn) *AV-Generation*)
  74.           (setf (avnode-newcontents ,avn) (copy-list (avnode-oldcontents ,avn)))))
  75.  
  76. ;;;  useful functions on avnodes
  77.  
  78. (defun follow-pointers (avnode)
  79.   "Follows a chain of pointer nodes until a non-pointer is reached"
  80.   (if (avnode-p avnode)
  81.     (let ((avnode-contents (avnode-contents avnode)))
  82.       (if (or (pointer-p avnode-contents) 
  83.               (constant-p avnode-contents))
  84.         (follow-pointers avnode-contents)
  85.         avnode))
  86.     avnode))
  87.  
  88. (defun avn-att-val (avnode att)
  89.   "Returns the value of avnode's att attribute, follows pointers"
  90.   (let ((contents (avnode-contents (follow-pointers avnode))))
  91.     (if (complex-p contents)
  92.       (avpairs-att-val contents att)
  93.       nil)))
  94.  
  95. (defun make-att-val (avnode att)
  96.   "Gets the value of avnode's att attribute, constructing such a node if necessary.
  97.  Returns NIL in case of failure."
  98.   (let* ((node (follow-pointers avnode))
  99.          (contents (avnode-contents node)))
  100.     (if (or (complex-p contents)
  101.             (variable-p contents))
  102.       (let ((val (avpairs-att-val contents att)))
  103.         (if val
  104.           val
  105.           (let ((new-node (make-avnode)))
  106.             (unless (UpToDate node)
  107.               (Copy-Contents node))
  108.             (if (avnode-newcontents node)  ; add to end of av-list
  109.               (setf (cdr (last (avnode-newcontents node))) (list (cons att new-node)))
  110.               (push (cons att new-node) (avnode-newcontents node)))
  111.             new-node)))
  112.       'nil)))
  113.  
  114. (defun unify-avs (av1 av2)
  115.   (let ((nav1 (follow-pointers av1))         ; follow all pointer nodes
  116.         (nav2 (follow-pointers av2)))
  117.     (if (eq nav1 nav2) 
  118.       nav1
  119.       (let ((cav1 (avnode-contents nav1))    ; get associated contents
  120.             (cav2 (avnode-contents nav2)))
  121.         (cond ((variable-p cav1) (smash-to-pointer nav1 nav2))  ; smash variables
  122.               ((variable-p cav2) (smash-to-pointer nav2 nav1))
  123.               ((or (constant-p cav1) (constant-p cav2)) nil)    ; no consts
  124.               (t (smash-to-pointer nav1 nav2)                   ; handle complex
  125.                  (unless (UpToDate nav2)
  126.                    (copy-contents nav2))
  127.                  (if (every #'(lambda (avp)
  128.                                 (setf nav2 (follow-pointers nav2))
  129.                                 (let ((node (avpairs-att-val (avnode-newcontents nav2) 
  130.                                                              (avpair-att avp))))
  131.                                   (if node
  132.                                     (unify-avs (avpair-val avp) node)
  133.                                     (push avp (avnode-newcontents nav2)))))
  134.                             cav1)
  135.                    nav2
  136.                    'nil)))))))
  137.  
  138. (defun subsume-avs-p (avs1 avs2)     ; t if avs1 is more general than avs2
  139.   (labels 
  140.     ((sub-avs (av1 av2)            ; subsumption differs from unification in that
  141.               (if (eq av1 av2)     ;  only the variables of av1 may be bound, and
  142.                 av1                ;  these may only be bound once!
  143.                 (let ((cav1 (avnode-contents av1))    ; get associated contents
  144.                       (cav2 (avnode-contents av2)))
  145.                   (cond ((pointer-p cav1) (eq (follow-pointers av1) av2))
  146.                         ((variable-p cav1) (smash-to-pointer av1 av2))  ; smash variables
  147.                         ((variable-p cav2) nil)
  148.                         ((or (constant-p cav1) (constant-p cav2)) nil)  ; no consts
  149.                         (t (smash-to-pointer av1 av2)                   ; complex
  150.                            (if (every #'(lambda (avp)
  151.                                           (sub-avp (avpair-att avp) 
  152.                                                    (avpair-val avp) 
  153.                                                    cav2))
  154.                                       cav1)
  155.                              av2
  156.                              nil))))))
  157.      (sub-avp (att val avpairs)
  158.               (if avpairs
  159.                 (if (eq att (avpair-att (first avpairs)))
  160.                   (sub-avs val (avpair-val (first avpairs)))
  161.                   (sub-avp att val (rest avpairs)))
  162.                 nil))
  163.      )
  164.     (sub-avs avs1 avs2)))
  165.  
  166. ;;; the idea is that we use new-contents as a scratch field into
  167. ;;; which we stuff the copy of the current node.  We indicate we have
  168. ;;; done this by using a new copy generation.
  169.  
  170. (defvar *Copy-Generation* (list '*copy*))   ;  The copy generation
  171.  
  172. (defun Reset-Copier () (setq *Copy-Generation* (list '*copy*)))
  173.  
  174. (defun copy-avs (avs-node)
  175.   (let ((node (follow-pointers avs-node)))    ; follow any pointers
  176.     (if (constant-p node)
  177.       node
  178.       (if (eq (avnode-generation node) *Copy-Generation*); this node has a copy
  179.         (avnode-newcontents node)                        ; return its copy
  180.         (let ((contents (avnode-contents node))          ; get the contents
  181.               (new-node (make-avnode)))                  ;  before we clobber them
  182.           (setf (avnode-generation node) *Copy-Generation*); stick copy node on
  183.           (setf (avnode-newcontents node) new-node)        ;   to node
  184.           (setf (avnode-oldcontents new-node)
  185.                 (mapcar #'(lambda (avp)
  186.                             (make-avpair (avpair-att avp)
  187.                                          (copy-avs (avpair-val avp))))
  188.                         contents))
  189.           new-node)))))
  190.  
  191. (defun restrict-avs (avs restrictor)
  192.   (let ((gen (list '*restrictor-generation*)))
  193.     (labels ((doNode (avs-node res-node)
  194.                 (let ((a (follow-pointers avs-node))    ; follow any pointers
  195.                       (r (follow-pointers res-node)))
  196.                   (if (constant-p a)            ; constants are never restricted
  197.                     a
  198.                     (if (eq (avnode-generation a) gen)   ; this node has a copy
  199.                       (avnode-newcontents a)             ; return its copy
  200.                       (let ((a-contents (avnode-oldcontents a)) ; get the contents
  201.                             (new-node (make-avnode)))  ;  before we clobber them
  202.                         (setf (avnode-generation a) gen)   ; stick copy node on
  203.                         (setf (avnode-newcontents a) new-node) ;   to node
  204.                         (if (complex-p (avnode-contents r))
  205.                           (setf (avnode-oldcontents new-node)
  206.                                 (doAvpairs a-contents (avnode-oldcontents r))))
  207.                         new-node)))))
  208.              (doAvpairs (apairs rpairs)
  209.                 (if apairs
  210.                   (let ((rpair (assoc (avpair-att (first apairs)) rpairs)))
  211.                     (if rpair
  212.                       (cons (make-avpair (avpair-att rpair)
  213.                                          (doNode (avpair-val (first apairs))
  214.                                                  (avpair-val rpair)))
  215.                             (doAvpairs (rest apairs) rpairs))
  216.                       (doAvpairs (rest apairs) rpairs)))
  217.                   '())))
  218.       (New-Generation)
  219.       (Reset-copier)
  220.       (doNode avs restrictor))))
  221.  
  222. (defvar *name-bindings* nil) ; a global name-bindings variable used only by
  223.                              ;  avs-to-list
  224.  
  225. (defun Reset-List-To-Avs () (setq *name-bindings* nil))
  226.  
  227. (defun list-to-avs (avs-data)
  228.   (labels ((var-sym (x) 
  229.                     (let ((s (string x)))
  230.                       (char= (elt s (1- (length s))) #\?)))
  231.            (lookup (name)
  232.                    (follow-pointers (cdr (assoc name *name-bindings*))))
  233.            (store (name value)
  234.                   (push (cons name value) *name-bindings*)
  235.                   value)
  236.            (build (data)
  237.                   (cond ((and (symbolp (first data))         ;; constant
  238.                               (not (var-sym (first data))))
  239.                          (first data))
  240.                         ((symbolp (first data))              ;; variable
  241.                          (or (lookup (first data))
  242.                              (let ((new-node (make-avnode)))
  243.                                (store (first data) new-node)
  244.                                (setf (avnode-oldcontents new-node)
  245.                                      (mapcar #'(lambda (p)
  246.                                                  (make-avpair (car p)
  247.                                                               (build (cdr p))))
  248.                                              (rest data)))
  249.                                new-node)))
  250.                         (t
  251.                          (make-avnode :oldcontents
  252.                                       (mapcar #'(lambda (p)
  253.                                                   (make-avpair (car p)
  254.                                                                (build (cdr p))))
  255.                                               data))))))
  256.     (build avs-data)))
  257.  
  258. (defun avs-to-list (avs)
  259.   (let ((copy-generation (list '*list-copy*)))
  260.     (labels ((doNode (avs-node)
  261.                 (let ((node (follow-pointers avs-node)))  
  262.                   (if (constant-p node)
  263.                     (list node)
  264.                     (if (eq (avnode-generation node) copy-generation)
  265.                       (avnode-newcontents node) 
  266.                       (let ((contents (avnode-contents node))
  267.                             (new-node (list '?)))         
  268.                         (setf (avnode-generation node) copy-generation)
  269.                         (setf (avnode-newcontents node) new-node)
  270.                         (let ((daughters
  271.                                (mapcar #'(lambda (avp)
  272.                                            (make-avpair (avpair-att avp)
  273.                                                         (doNode (avpair-val avp))))
  274.                                        contents)))
  275.                           (when daughters
  276.                             (setf (car new-node) (car daughters))
  277.                             (setf (cdr new-node) (cdr daughters)))
  278.                           new-node)))))))
  279.       (doNode avs))))
  280.  
  281.  
  282.  
  283. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  284.  
  285. ;;;  AVG
  286.  
  287. ;;; A grammar exports the following functions
  288. ;;;
  289. ;;; (ExpandMother g cat)
  290. ;;; (LeftDaughter g rule)
  291. ;;; (ShiftRule g rule cat)
  292. ;;; (ReduceRule g rule)
  293. ;;; (SubsumeCat g cat1 cat2)
  294. ;;; (UnifyCat g cat1 cat2)
  295. ;;; (RestrictCat g cat)
  296. ;;; (Lexicon g word)
  297. ;;; (StartCat g)
  298.  
  299.  
  300. (defun rules (grammar) (first grammar))
  301. (defun lex-forms (grammar) (second grammar))
  302. (defun start (grammar) (third grammar))
  303. (defun restrictor (grammar) (fourth grammar))
  304.  
  305. (defstruct rule mother daughters)           ; a dotted rule
  306.  
  307. (defun BuildGrammar (grammar-rules lexicon start restriction)
  308.   (list (mapcar #'(lambda (r) 
  309.                     (Reset-list-to-avs)         ; reset all the lexical bindings
  310.                     (make-rule :mother (list-to-avs (first r))
  311.                                :daughters (mapcar #'list-to-avs
  312.                                                   (rest (rest r)))))
  313.                 grammar-rules)
  314.         (mapcar #'(lambda (lex)
  315.                     (cons (first lex)
  316.                           (mapcar #'(lambda (l)
  317.                                       (Reset-list-to-avs)
  318.                                       (list-to-avs l))
  319.                                   (rest lex))))
  320.                 lexicon)
  321.         (progn (Reset-list-to-avs)
  322.                (list-to-avs start))
  323.         (progn (Reset-list-to-avs)
  324.                (list-to-avs restriction))))
  325.  
  326. (defun ExpandMother (g cat)
  327.   (mapcan #'(lambda (r)
  328.               (New-Generation)
  329.               (when (Unify-avs (rule-mother r) cat)
  330.                 (Reset-Copier)
  331.                 (list (make-rule :mother (Copy-avs (rule-mother r))
  332.                                  :daughters (mapcar #'Copy-avs
  333.                                                     (rule-daughters r))))))
  334.           (rules g)))
  335.  
  336. (defun LeftDaughter (g rule)
  337.   (declare (ignore g))
  338.   (first (rule-daughters rule)))
  339.  
  340. (defun ShiftRule (g rule cat)
  341.   (let ((first-daughter (LeftDaughter g rule)))
  342.     (when (and first-daughter 
  343.                (New-Generation)
  344.                (Unify-avs first-daughter cat))
  345.       (Reset-Copier)
  346.       (make-rule :mother (Copy-avs (rule-mother rule))
  347.                  :daughters (mapcar #'Copy-avs 
  348.                                     (rest (rule-daughters rule)))))))
  349.  
  350. (defun ReduceRule (g rule)
  351.   (declare (ignore g))
  352.   (if (null (rule-daughters rule))
  353.     (rule-mother rule)))
  354.  
  355. (defun SubsumeCat (g cat1 cat2)
  356.   (declare (ignore g))
  357.   (New-Generation)
  358.   (Subsume-avs-p cat1 cat2))
  359.  
  360. (defun RestrictCat (g cat)
  361.   (Restrict-avs cat (restrictor g)))
  362.  
  363. (defun UnifyCat (g cat1 cat2)
  364.   (declare (ignore g))
  365.   (New-Generation)
  366.   (Unify-avs cat1 cat2))
  367.  
  368. (defun StartCat (g)
  369.   (third g))
  370.  
  371. (defun Lexicon (g w)
  372.   (let ((categories (cdr (assoc w (lex-forms g)))))
  373.     (unless categories
  374.       (format t "Warning: The word ~s does not appear in the lexicon!~%" w))
  375.     categories))
  376.  
  377. (defun CatPrintForm (g cat)
  378.   (declare (ignore g))
  379.   (avs-to-list cat))
  380.  
  381. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  382.  
  383. ;;;  Chart
  384.  
  385. (defstruct search rule parent daughters)
  386. (defstruct goal cat loc instances parents)
  387. (defstruct inst cat loc daughters)
  388. (defstruct lex cat loc word)
  389.  
  390. (defvar *database* nil)
  391. (defvar *lexical-database* nil)
  392.  
  393. (defvar *g*)          ; the grammar.  This must be bound elsewhere!
  394.  
  395. (defvar *tracer* '())  ; list of places where tracing takes place.
  396.  
  397. (defun Seek (cat from parent)
  398.   (let* ((old-goal (lookup-goal cat from)))
  399.     (if old-goal
  400.       (progn 
  401.         (push parent (goal-parents old-goal))
  402.         (dolist (i (goal-instances old-goal))
  403.           (inform parent i))
  404.         old-goal)
  405.       (let* ((r-cat (RestrictCat *g* cat))
  406.              (new-goal (create-goal r-cat from parent)))
  407.         (if (member 'seek *tracer*)
  408.           (format t "Looking for ~s at location ~s~%" 
  409.                   (CatPrintForm *g* r-cat) from))
  410.         (CheckLex new-goal)
  411.         (dolist (r (ExpandMother *g* r-cat))
  412.           (process-rule r from new-goal nil))
  413.         new-goal))))
  414.  
  415. (defun inform (s i)
  416.   (let ((new-rule (ShiftRule *g* (search-rule s) (inst-cat i))))
  417.     (if new-rule
  418.       (process-rule new-rule (inst-loc i) (search-parent s)
  419.                     (cons i (search-daughters s))))))
  420.  
  421. (defun process-rule (rule loc parent daughters)
  422.   (let ((daughter (LeftDaughter *g* rule)))
  423.     (if daughter
  424.       (Seek daughter loc (make-search :rule rule :parent parent
  425.                                       :daughters daughters))))
  426.   (let ((mother (ReduceRule *g* rule)))
  427.     (if mother
  428.       (found parent mother loc (reverse daughters)))))
  429.  
  430. (defun found (goal cat loc daughters)
  431.   (if (member 'found *tracer*)
  432.     (format t "Found ~s from ~s to ~s~%" 
  433.             (CatPrintForm *g* cat) (goal-loc goal) loc))
  434.   (let ((new-instance (make-inst :cat cat :loc loc :daughters daughters)))
  435.     (push new-instance (goal-instances goal))
  436.     (dolist (s (goal-parents goal))
  437.       (inform s new-instance))))
  438.  
  439. (defun Create-goal (cat loc parent)
  440.   (let ((new-goal (make-goal :cat cat
  441.                              :loc loc
  442.                              :parents (if parent (list parent)))))
  443.     (push new-goal *database*)
  444.     new-goal))
  445.  
  446. (defun Lookup-goal (cat loc)
  447.   (find-if #'(lambda (g)
  448.                (and (= (goal-loc g) loc)
  449.                     (SubsumeCat *g* (goal-cat g) cat)))
  450.            *database*))
  451.  
  452. (defun chart (words)
  453.   (setq *database* '())
  454.   (setq *lexical-database* '())
  455.   (LoadWords words 0)
  456.   (mapcar #'(lambda (i) 
  457.               (list (InstToTreeList i)
  458.                     (CatPrintForm *g* (inst-cat i))))
  459.           (goal-instances (Seek (Startcat *g*) 0 nil))))
  460.  
  461. (defun LoadWords (words loc)
  462.   (when words
  463.     (dolist (cat (Lexicon *g* (first words)))
  464.       (AddWord cat loc (first words)))
  465.     (LoadWords (rest words) (+ 1 loc))))
  466.  
  467. (defun AddWord (cat loc word)
  468.   (push (make-lex :cat cat :loc loc :word word) *lexical-database*)
  469.   (dolist (g *database*) 
  470.     (if (and (= (goal-loc g) loc) 
  471.              (UnifyCat *g* (goal-cat g) cat))
  472.       (found g cat (1+ loc) nil))))
  473.  
  474. (defun CheckLex (goal)
  475.   (dolist (l *lexical-database*)
  476.     (if (and (= (lex-loc l) (goal-loc goal))
  477.              (UnifyCat *g* (goal-cat goal) (lex-cat l)))
  478.       (found goal (lex-cat l) (1+ (lex-loc l)) (list (lex-word l))))))
  479.  
  480. (defparameter *cat-prefix* 'cat "the prefix to follow to find the category label")
  481.  
  482. (defun InstToTreeList (inst)
  483.   "builds a conventional phrase structure tree for this inst"
  484.   (labels ((label (i)
  485.                   (let ((c (if *cat-prefix*
  486.                              (avn-att-val (inst-cat i) *cat-prefix*)
  487.                              (inst-cat i))))
  488.                     (if (symbolp c)
  489.                       c
  490.                       (avs-to-list c)))))
  491.     (if (inst-p inst)
  492.       (if (inst-daughters inst)
  493.         (cons (label inst)
  494.               (mapcar #'InstToTreeList (inst-daughters inst)))
  495.         (label inst))
  496.       inst)))
  497.   
  498. (defvar *results* '())   ; where the results of the last computation are stored
  499.  
  500. (defun parse (words)
  501.   (setq *database* '())
  502.   (setq *lexical-database* '())
  503.   (LoadWords words 0)
  504.   (let ((len (length words))
  505.         (start (Startcat *g*)))
  506.     (setq *results* 
  507.           (remove-if-not 
  508.            #'(lambda (i)
  509.                (and (= (inst-loc i) len)
  510.                     (UnifyCat *g* start (inst-cat i))))
  511.            (goal-instances (Seek start 0 nil)))))
  512.   (New-Generation)         ; ensure that there are no false bindings!
  513.   (format t "There are ~s results~%" (length *results*))
  514.   (when *results*
  515.     (Display 1)
  516.     (format t "~%Enter (Display n) to see other results")))
  517.  
  518. (defmacro p (&rest words)
  519.   `(parse ',words))
  520.  
  521. #|
  522. (defun Display (n)
  523.   (if (<= 1 n (length *results*))
  524.     (let ((e (elt *results* (- n 1)))
  525.           (*print-pretty* t)
  526.           (*print-circle* t))
  527.       (format t "~%Result ~a~%" n)
  528.       (format t "~%~a~%" (InstToTreeList e))
  529.       (format t "~%~a~%" (avs-to-list (if *val-prefix*
  530.                                         (make-att-val (inst-cat e) *val-prefix*)
  531.                                         (inst-cat e)))))
  532.     (format t "Sorry, there are only ~s results~%" (length *results*))))
  533. |#
  534.  
  535. (defun Instance-Count ()
  536.   "Counts the number of instances found during the last parse"
  537.   (apply #'+ (mapcar #'(lambda (g)
  538.                          (length (goal-instances g))) *database*)))